perm filename TRNSP.F4[PAG,LCS]6 blob
sn#519478 filedate 1980-07-01 generic text, type T, neo UTF8
00100 COMMENT ⊗ VALID 00002 PAGES
00200 C REC PAGE DESCRIPTION
00300 C00001 00001
00400 C00002 00002 C**** TRNSP, RVRS, BMGHT, CUES ***************
00500 C00024 ENDMK
00600 C⊗;
00100 C**** TRNSP, RVRS, BMGHT, CUES ***************
00200 SUBROUTINE TRNSP
00300 COMMON /PX/KPN(1) /Q/Q(1) /XRN/RN(1)
00400 COMMON/STF/RSTFAC(0/7),RSTJ2 /IPG/IPG,JPG,BRACK(8),
00500 1 RSTNUM(8),RPSZ(8),RHGT(8),RCLEF(0/7)
00600 1 /RCLF/KK,CLEF,KW,ITEM,RSTAFF,SN,YN,RNAM,IRV,ITR
00700 COMMON /FIN/JBAR,NPX,REND,KPX,KREAD,JEND,JSLUR,JSL2,NAMZ
00800 1,LC,LPG,MPG,ZCLEF,SIG,LB,SPG,MTR1,MTR2
00900 1 /LLL/LEND,NO1,NI,NO3,XSIG /RSIG/RSIG(0/7)
01000 1 /TRAN/RTR(17),KTR(17)
01100 DATA RTR/5.,5.,4.,4.,3., 2.,2.,1.,1.,1., -1.,-1.,-2.,-2.,-3.
01200 1 ,-4.,8./,KTR/3,-4,1,-6,-1, 4,-3,2,-5,0, 5,-2,3,-4,1, -1,2/
01300
01400 IOCT=0
01500 RXT=99.
01600 KW=0
01700 IF(ITR.LE.17)GO TO 1002
01800 IADD=0
01900 RT=7
02000 C OCTAVE ↑ = 19, - = 18
02100 IF(ITR.EQ.18)RT=-RT
02200 IOCT=-1
02300 GO TO 199
02400 1002 IF(SIG.NE.-99)GO TO 199
02500 C FOUND KSIG, SO DON'T DO THE REST
02600 IF(XSIG.NE.0)GO TO 2002
02700 RT=0
02800 IF(ITR.EQ.0)RETURN
02900 RT=RTR(ITR)
03000 C EEb,EE,F-,F#-,G, Ab,A,Bb,B,DMY, Db,D,Eb,E,F,G↑ BBb, 8-, 8↑
03100 41 NSIG=-1
03200 IF(RSIG(KW).NE.99)GO TO 699
03300 C ASSUMES KSIG DESIRED IF ONE THERE ALREADY.
03400 IF(ZSIG(XSIG).NE.'Y')GO TO 199
03500 C FUNCTION ZSIG ASKS 'ADD KEY SIG?'
03600 699 NSIG=0
03700 XSIG=99
03800
03900 C ***** NEXT FOR KEY SIG. ********
04000 IADD=KTR(ITR)
04100 C EEb,EE,F-,F#-,G, Ab,A,Bb,B,DMY, Db,D,Eb,E,F,G↑ BBb, 8-, 8↑
04200 2002 K=0
04300 2003 R=0
04400 RZ=RSIG(K)
04500 IF(RZ.NE.99)R=RZ
04600 R=IADD+R
04700 IF(R.EQ.0)GO TO 799
04800 A=ABS(R)
04900 IF(A.LT.8.OR.A.GE.100)GO TO 899
05000 C IF IMPOSSIBLE KSIG, DO ENHARMONIC SHIFT (NATURALS KSIG IS OK)
05100 IF(R.LT.0)GO TO 1899
05200 R=R-12
05300 ITR=9
05400 RT=RT+1
05500 GO TO 899
05600 1899 R=R+12
05700 ITR=11
05800 RT=RT-1
05900 899 IF(IPG.GT.0)GO TO 799
06000 C SKIP IF TRNSP ONLY.
06100 IF(RZ.NE.99)GO TO 799
06200 SIG=0
06300 CALL STAFF(4.,17.,4.0*RSTJ2,0,R,CLEF,0,0,0,0,0,0)
06400 799 RSIG(K)=R
06500 K=K+1
06600 IF(K.LT.JPG)GO TO 2003
06700 199 K=1
06800 CC CLEF=RCLEF(KW)
06900 SLUR=0
07000 PRX=99
07100 MS=200
07200 SN=KW
07300 599 X=CODEN(KPN,K,Q,J)
07400 IF(X.EQ.4)GO TO 2
07500 IF(Q(J+2).NE.SN)GO TO 100
07600 CHECK FOR STAFF NUM.
07700 IF(X.EQ.1)GO TO 1
07800 IF(X.NE.3)GO TO 20
07900 CC IF(IPG.GT.0)GO TO 100
08000 CLEF=Q(J+5)
08100 IF(Q(J).LT.3)CLEF=0
08200 CIRC IF(ITR.EQ.16.OR.ITR.EQ.3)GO TO 21
08300 IF(ITR.NE.17.AND.ITR.NE.3)GO TO 100
08400 C NEXT FOR HORN IN F CLEF CHANGES**** NOW ONLY BS.CLAR 10/79
08500 CIRC GO TO 100
08600 C NEXT FOR BASS CL. CLEF CHANGES.
08700 21 IF(CLEF.NE.0)Q(J+5)=0
08800 IF(RXT.NE.99.)RXT=RT
08900 C RESET DISPLACEMENT WHEN PART IS IN TREBLE CLEF.
09000 IF(Q(J+4).LT.100.)GO TO 100
09100 CALL SHRNK(K,LEND)
09200 C MAKE IT INVISIBLE IF IT WAS MINI.
09300 GO TO 599
09400 2 BAR=-1
09500 MS=200
09600 GO TO 100
09700 20 IF(X.NE.17)GO TO 12
09800 C HOW ABOUT CHANGE TO NO SIG? OK, CODE =99
09900 R=Q(J+5)
10000 C KSIG NUM.
10100 A=R+IADD
10200 CHANGED TO A
10300 CIRC IF(A.GE.8)A=A-12
10400 CIRC IF(A.LE.-8)A=A+12
10500 CIRC IF(A.NE.0)GO TO 23
10600 CIRC A=100
10700 CHANGE KSIG TO NATURALS
10800 CIRC IF(R)A=-A
10900 CIRC A=R+A
11000 CIRC RSIG(KW)=A
11100 CC RSIG(KW)=99
11200 IF(ABS(A).LT.8)GO TO 423
11300 C AVOIDS IMPOSSIBLE KSIG, DOES ENHARMONIC CHANGE.
11400 IF(A.LT.0)GO TO 223
11500 ITR=9
11600 A=A-12
11700 RT=RT+1
11800 GO TO 423
11900 223 A=A+12
12000 ITR=11
12100 RT=RT-1
12200 423 IF(A.NE.0)GO TO 23
12300 M=Q(J)+3
12400 C THIS WILL DELETE KSIG
12500 ITOT=KPN(LEND+1)-1
12600 323 ITOT=ITOT-M
12700 KL=ITOT-J+1
12800 CALL RLOOP(Q(J),Q(J+M),KL)
12900 DO 334 J=K,LEND
13000 334 KPN(J)=KPN(J+1)-M
13100 LEND=LEND-1
13200 NI=NI-1
13300 C NI IS I IN WRTPAG.
13400 K=K-1
13500 GO TO 100
13600 23 Q(J+5)=A
13700 IF(ITR.NE.17.AND.ITR.NE.3)GO TO 523
13800 IF(CLEF.EQ.1.)Q(J+6)=0
13900 C PUTS HORN AND BS.CLAR BASS CLEF KEY SIG UP TO TREB. POSITION
14000 523 NSIG=0
14100 12 IF(X.NE.5)GO TO 123
14200 SLUR=Q(J+6)
14300 GO TO 121
14400 C SAVES RIGHT POS. OF SLUR
14500 123 IF(X.NE.6)GO TO 100
14600 121 A=RT
14700 C FOR BEAMS AND SLURS
14800 CIRC IF(A.EQ.8)GO TO 122
14900 CIRC IF(A.NE.4)GO TO 124
15000 IF(ITR.NE.17.AND.ITR.NE.3)GO TO 124
15100 C A=8=BS.CL. =4=HRN MOVES BEAMS AND SLURS IF CLEF CHANGE
15200 122 IF(CLEF.EQ.1)A=A-12
15300 C BASS CLEF → TREBLE
15400 124 Q(J+4)=Q(J+4)+A
15500 Q(J+5)=Q(J+5)+A
15600 C ASSUMES NO CLEF CHANGE BETWEEN END POINTS OF SLUR OR BEAM.
15700 GO TO 100
15800
15900 1 IF(Q(J).GE.7.AND.Q(J+9).LT.0)GO TO 100
16000 C IF P9 IS NEG. IT'S A NOTE WITHOUT LEDGER LINES. IGNORE IT.
16100 R=Q(J+4)
16200 XRT=RT
16300 IF(Q(J).LT.6)GO TO 111
16400 C SKIP IF NO STEM INFO
16500 RX=Q(J+8)
16600 IF(RX.GT.999.0)GO TO 111
16700 IF(RX.EQ.999.0)RX=0
16800 RX=RX+RT
16900 IF(RX.LT.0)RX=0
17000 C RESET STEM LENGTH. NEVER SHORTER THAN 0 (NORMAL).
17100 Q(J+8)=RX
17200 111 IF(IOCT.LT.0)GO TO 4
17300 C IOCT=-1 FOR OCT+ OR OCT-
17400 RX=AMOD(R,100.0)
17500 RZ=AMOD(RX,7.0)
17600 C THE NOTE NUM
17700 IF(RZ.LT.0)RZ=RZ+7
17800 C PUTS IT IN 0-6 RANGE FOR ACCI CHANGE SECTION.
17900 R5=Q(J+5)
18000 A=AMOD(R5,10.0)
18100 C THE ACCI
18200 RN(MS)=A
18300 RN(MS+1)=RX
18400 C SAVE FOR REPEATS
18500 MS=MS+2
18600 CHNAT=3
18700 IF(MS.LT.203)GO TO 205
18800 N=MS-3
18900 200 IF(RX.NE.RN(N))GO TO 201
19000 IF(A.EQ.0)GO TO 444
19100 C NOW WE'VE FOUND THE SAME NOTE WITH NO ACCI IN SAME MEAS.
19200 GO TO 203
19300 201 N=N-2
19400 IF(N.GE.200)GO TO 200
19500 205 IF(NSIG.LT.0)CHNAT=0
19600 203 ADD=A
19700 C THE CHANGE IN ACCI
19800 IF(PRX.NE.RX)GO TO 44
19900 C IF PREV ACCI AND NT ARE SAME, SKIP OVER.
20000 IF(A.NE.0)GO TO 44
20100 C NOW SAME NOTE, NO ACCI
20200 IF(ABS(SLUR-Q(J+3)).GT.3)GO TO 44
20300 C FOUND CONNECTING TIE
20400 C THIS ↑↑↑↑ ALWAYS PUTS ACCI AFTER A BAR -- EVEN WITH TIE------
20500 C OR SET MS BACK TO 200 WHEN TIE IS PRESENT. THIS WILL
20600 CAUSE LATER SAME NOTE TO HAVE ACCI (I HOPE.)
20700 IF(BAR.LT.0)MS=200
20800 IF(A.NE.0)GO TO 203
20900 GO TO 444
21000 44 IF(NSIG.LT.0)GO TO 440
21100 CCC IF(ITR.GE.17)GO TO 69
21200 IF(A.EQ.0)GO TO 444
21300 C ONLY CHECKS ON NOTES WITH NO ACCI
21400 IF(ITR.GE.18)GO TO 444
21500
21600
21700 440 IF(CLEF.NE.1)GO TO 69
21800 RZ=RZ-5
21900 IF(RZ.LT.0)RZ=RZ+7
22000 CC69 GO TO (63,52,53,54,55, 56,57,58,59,440, 61,62,63,52,53,55
22100 69 N=A+1
22200 GO TO (63,52,64,54,55, 56,57,58,59,440, 61,62,63,52,53,55
22300 1 ,64),ITR
22400 C EEb,EE,F↓,F#↓,G, Ab,A,Bb,B,DMY, Db,D,Eb,E,F,G↑ BBb
22500 54 IF(RZ.EQ.3)GO TO 101
22600 59 IF(RZ.EQ.6)GO TO 101
22700 52 IF(RZ.EQ.2)GO TO 101
22800 57 IF(RZ.EQ.5)GO TO 101
22900 C FOR "A". FINDS C,F AND G.
23000 62 IF(RZ.EQ.1)GO TO 101
23100 55 IF(RZ.EQ.4)GO TO 101
23200 C "G" F→Bb, F#→B NAT.
23300 GO TO 4
23400 61 IF(RZ.EQ.5)GO TO 7
23500 56 IF(RZ.EQ.2)GO TO 7
23600 63 IF(RZ.EQ.6)GO TO 7
23700 58 IF(RZ.EQ.3)GO TO 7
23800 53 IF(RZ.NE.0)GO TO 4
23900
24000 7 GO TO(402,30,405,402,401)N
24100 CIRC7 IF(A.EQ.0)GO TO 402
24200 CIRC IF(A.EQ.3)GO TO 402
24300 C CHNG NO ACCI OR NAT TO SHARP
24400 CIRC IF(A.EQ.4)GO TO 401
24500 C 4=bb 5=##
24600 CIRC IF(A.EQ.2)GO TO 405
24700 30 ADD=CHNAT
24800 C MAKE IT NAT. IF NEEDED
24900 3 Q(J+5)=R5-A+ADD
25000 4 PRX=RX
25100 C REAL NOTE LEVEL
25200 Q(J+4)=R+XRT
25300 BAR=0
25400 RXT=XRT
25500 100 IF(K.GE.LEND)GO TO 499
25600 K=K+1
25700 GO TO 599
25800
25900
26000 C NEXT FOR BSCLAR.---ADD OTHERS HERE!!!
26100 64 IF(CLEF.EQ.1)XRT=XRT-12
26200 IF(ITR.EQ.3)GO TO 53
26300 GO TO 58
26400 444 IF(ITR.NE.17.AND.ITR.NE.3)GO TO 544
26500 IF(CLEF.EQ.1.)XRT=XRT-12
26600 C FOR HORN AND BS.CLAR CHANGE FROM BASS TO TREB. CLEF
26700 544 IF(RXT.NE.99.)XRT=RXT
26800 C THIS FOR BS.CL. AND HRN. REPEATED NOTES.
26900 GO TO 4
27000
27100 101 GO TO(401,404,30,401,404,402)N
27200 CIRC101 IF(A.EQ.0)GO TO 401
27300 CIRC IF(A.EQ.2)GO TO 30
27400 CIRC IF(A.EQ.3)GO TO 401
27500 CIRC IF(A.EQ.5)GO TO 402
27600 C WON'T HANDLE Gbb→Ab
27700 404 ADD=4
27800 GO TO 3
27900 401 ADD=1
28000 GO TO 3
28100
28200 402 ADD=2
28300 GO TO 3
28400 405 ADD=5
28500 GO TO 3
28600 499 KW=KW+1
28700 IF(KW.LT.JPG)GO TO 199
28800 CALL RVRS(LEND)
28900 C TO REVERSE STEMS, BEAMS AND SLURS
29000 END
29100
29200
29300
29400 SUBROUTINE RVRS(LEND)
29500 COMMON /PX/KPN(1) /Q/Q(1) /XRN/RN(1)
29600 1 /RCLF/KK,CLEF,KW,ITEM,RSTAFF,SN,YN,RNAM,IRV,ITR
29700 1 /IPG/IPG,JPG,BRA(8),RSTNUM(8),RPSZ(8),RHGT(8),RCLEF(8)
29800 DATA RSTEM/6.5/
29900 KW=0
30000 CZZ IRV=0
30100 CZZ IF(ITR.LT.10)GO TO 100
30200 CZZ IF(ITR.NE.18)IRV=-1
30300 C TRNS ↓ + STEM ↑ = NO CHNG, TRNS ↑ +STEM ↓ = NO CHNG
30400 100 K=1
30500 SN=KW
30600 DO 30 N=1,LEND
30700 IF(CODEN(KPN,N,Q,J).NE.1)GO TO 30
30800 C LOOK FOR NOTES WITH STEM BUT NO RHYTH. VALUE
30900 IF(Q(J+2).NE.SN)GO TO 30
31000 C ON THIS STAFF?
31100 IF(Q(J).LT.7)GO TO 31
31200 IF(Q(J+9).NE.0)GO TO 30
31300 31 IF(Q(J+5).GE.10)GO TO 102
31400 C FOUND A 0 RHYTHM WITH A STEM - IGNORE THIS STAFF
31500 30 CONTINUE
31600
31700 1 R=CODEN(KPN,K,Q,J)
31800 IF(Q(J+2).NE.SN)GO TO 10
31900 CHECK ON STAFF NUM.
32000 IF(R.NE.1)GO TO 2
32100 C JUMP IF NOT A NOTE
32200 CZZ IF(NORVRS(Q(J+5)))GO TO 10
32300 CHECKS STEM DIR. AND TRNS DIR.
32400 IF(Q(J+5).LT.10)GO TO 10
32500 C JUMP IF NO STEM ON IT
32600 IF(Q(J).GT.6.AND.Q(J+9).LT.0)GO TO 10
32700 C SKIP NOTES WITH NO LEDGER LINES
32800 KK=K+1
32900 3 IF(KK.GT.LEND)GO TO 102
33000 RR=CODEN(KPN,KK,Q,JJ)
33100 IF(Q(JJ+2).EQ.SN)GO TO 101
33200 GO TO 7
33300 101 IF(RR.NE.1)GO TO 5
33400 C JUMP IF NOT A NOTE
33500 IF(Q(JJ+5).GE.10)GO TO 6
33600 C SKIP CHORD NOTES (NO STEM)
33700 7 KK=KK+1
33800 GO TO 3
33900 C DID NOT FIND BEAM NEARBY
34000 6 RZ=AMOD(Q(J+4),100.0)
34100 N=J+5
34200 A=10
34300 IF(RZ.GE.7)GO TO 60
34400 IF(Q(N).LT.20)GO TO 10
34500 C NOW STEM SHOULD BE DOWN IF WITHOUT BEAM OR 1ST NT UNDER BEAM.
34600 A=-A
34700 GO TO 15
34800 60 IF(Q(N).GE.20)GO TO 10
34900 C THERE MUST BE A BETTER WAY!
35000 15 Q(N)=Q(N)+A
35100 GO TO 10
35200
35300 CCC5 IF(RR.NE.6)GO TO 6
35400 5 IF(RR.EQ.6)GO TO 20
35500 IF(Q(JJ+3).NE.Q(J+3))GO TO 6
35600 CATCHES OTHER THINGS AT EXACTLY SAME POS. AS NOTE AND BEAM.
35700 KK=KK+1
35800 GO TO 3
35900
36000 20 B=Q(JJ+4)
36100 C=Q(JJ+5)
36200 D=(B+C)/2.
36300 IF(RR.EQ.5)GO TO 9
36400 IF(RR.NE.6)GO TO 10
36500
36600 CALL BMHGT(B,C,JJ)
36700 120 B=Q(JJ+6)+.5
36800 C SAVES RANGE OF BEAM +1.
36900 IF(Q(JJ+7).GE.20)GO TO 11
37000 C NOW STEMS ARE UP
37100 IF(D.LT.RSTEM)GO TO 12
37200 C JUMP TO 12 IF ALL OK
37300 IF(AVERG(K,JJ,LEND).EQ.0)GO TO 12
37400 C JUMP IF NOTE LEVELS DO NOT CALL FOR REVERSED STEMS
37500 JSTM=0
37600 C SAVE FOR REVERSED STEMS
37700 GO TO 23
37800 11 IF(D.GE.RSTEM)GO TO 12
37900 C STEMS DOWN
38000 C JUMP IF NO REVERSE NEEDED
38100 IF(AVERG(K,JJ,LEND).NE.0)GO TO 12
38200 C JUMP IF NOTE LEVELS DO NOT CALL FOR REVERSED STEMS
38300 JSTM=-1
38400 23 JH=0
38500 CHNG=0
38600 N=K
38700 164 R=CODEN(KPN,N,Q,KK)
38800 IF(Q(KK+2).NE.SN)GO TO 16
38900 IF(Q(KK+3).GT.B)GO TO 140
39000 IF(R.NE.1)GO TO 17
39100 L=5+KK
39200 IF(Q(L).LT.10)GO TO 16
39300 C PASS NOTES WITH NO STEM
39400 R=Q(KK+8)
39500 C THE STEM LENGTH
39600 IF(R.EQ.999)R=0
39700 Q(KK+8)=-R
39800 C FOR THE INVERSION
39900 19 BC=10.
40000 A=Q(L)
40100 IF(A.GE.20)BC=-BC
40200 Q(L)=BC+A
40300 IF(JH.NE.0)GO TO 161
40400 C NEXT FOR 1ST NOTE UNDER BEAM
40500 JH=4
40600 160 R=Q(JJ+JH)-Q(KK+4)
40700 A=-1
40800 IF(JSTM.LT.0)GO TO 163
40900 A=R
41000 R=1
41100 C NOW STEMS UP
41200 163 IF(R.GT.A)GO TO 162
41300 C JUMP IF BEAM IS NOT TOO CLOSE TO NOTE
41400 CHNG=A-R
41500 IF(JSTM.EQ.0)CHNG=-CHNG
41600 162 IF(L.LT.0)GO TO 141
41700 C FOR ESCAPE FROM LOOP
41800 161 JH=KK
41900 C JH SAVES PTR TO LAST NOTE UNDER BEAM
42000 GO TO 16
42100 17 IF(R.NE.6)GO TO 18
42200 C NOW IT'S A BEAM
42300 L=7+KK
42400 CALL BMHGT(Q(KK+4),Q(KK+5),KK)
42500 GO TO 19
42600 18 IF(R.NE.5)GO TO 16
42700 C NOW IT'S A SLUR
42800 C=-4
42900 IF(Q(KK+8).LT.-1)C=-1.8
43000 IF(Q(KK+7).LT.0)C=-C
43100 CALL SLRV(KK,C)
43200 C TO REVERSE SLUR
43300 16 N=N+1
43400 IF(N.LE.LEND)GO TO 164
43500 C SHOULD ALWAYS EXIT FROM LOOP BEFORE END OF ARRAY!
43600 140 KK=JH
43700 L=-1
43800 JH=5
43900 C GO BACK TO CHECK HGT OF LAST NOTE AND RIGHT END OF BEAM
44000 GO TO 160
44100
44200 141 IF(CHNG.EQ.0)GO TO 14
44300 C=CHNG
44400 IF(CHNG.LT.0)CHNG=-CHNG
44500 DO 142 N=K,LEND
44600 C TO READJUST STEMS UNDER REVERSED BEAMS
44700 R=CODEN(KPN,N,Q,KK)
44800 IF(Q(KK+2).NE.SN)GO TO 142
44900 IF(Q(KK+3).GT.B)GO TO 14
45000 CC IF(R.NE.1)GO TO 242
45100 CC Q(KK+8)=Q(KK+8)+CHNG
45200 C THE STEM LENGTH
45300 CC GO TO 142
45400 242 IF(R.NE.6)GO TO 142
45500 Q(KK+4)=Q(KK+4)+C
45600 Q(KK+5)=Q(KK+5)+C
45700 142 CONTINUE
45800 GO TO 14
45900
46000 C NEXT FOR SLURS
46100 9 B=-4
46200 IF(Q(JJ+8).LT.-1)B=-1.8
46300 IF(Q(JJ+7).LT.0)GO TO 24
46400 IF(D.GT.RSTEM)GO TO 10
46500 C JUMP TO LEAVE STEM UP
46600 GO TO 25
46700 24 IF(D.LT.5)GO TO 10
46800 C JUMP TO LEAVE STEM DOWN
46900 B=-B
47000 25 CALL SLRV(JJ,B)
47100 GO TO 10
47200 12 DO 13 N=K+1,LEND
47300 KK=KPN(N)
47400 IF(Q(KK+2).NE.SN)GO TO 13
47500 C IS THIS NEEDED↑↑↑↑??
47600 IF(Q(KK+3).GT.B)GO TO 14
47700 IF(Q(KK+1).EQ.6.)CALL BMHGT(Q(KK+4),Q(KK+5),KK)
47800 13 CONTINUE
47900 C JUMP OUT WHEN PAST END OF BEAM.
48000 14 IF(N.GT.K)K=N-1
48100 C ↑↑↑↑↑↑ WHY????????????
48200 GO TO 10
48300
48400 2 IF(R.NE.6)GO TO 21
48500 CZZ IF(NORVRS(Q(J+7)))GO TO 10
48600 22 JJ=J
48700 RR=R
48800 GO TO 20
48900 CZZ21 IF(R.NE.5)GO TO 10
49000 CZZ RR=20
49100 CZZ IF(Q(J+7))RR=10
49200 CZZ IF(NORVRS(RR).GE.0)GO TO 22
49300 21 IF(R.EQ.5)GO TO 22
49400
49500 10 IF(R.NE.1)GO TO 202
49600 C NEXT FIXES STEM LENGTHS
49700 B=0
49800 A=AMOD(Q(J+4),100.0)
49900 IF(A.GE.80)A=A-100.
50000 C A=HEIGHT OF NOTE
50100 IF(Q(J+5).GE.20.)GO TO 302
50200 C JUMP IF STEMS ARE DOWN
50300 IF(A.LT.0)B=-A
50400 C LENGTHEN STEM IF NOTE IS TOO FAR BELOW STAFF
50500 GO TO 402
50600 302 IF(A.GT.14)B=A-14.
50700 402 Q(J+8)=B
50800
50900 202 IF(K.GT.LEND)GO TO 102
51000 K=K+1
51100 GO TO 1
51200 102 KW=KW+1
51300 IF(KW.LT.JPG)GO TO 100
51400 END
51500
51600 CZZ FUNCTION NORVRS(R)
51700 CZZ COMMON /RCLF/KK,CLEF,KW,ITEM,RSTAFF,SN,YN,RNAM,IRV,ITR
51800 CZZ NORVRS=0
51900 CZZ IF(R.LT.20)GO TO 1
52000 C NOW STEM UP
52100 CZZ IF(IRV)RETURN
52200 CZZ2 NORVRS=-1
52300 CZZ RETURN
52400 CZZ1 IF(IRV)GO TO 2
52500 CZZ END
52600
52700 SUBROUTINE BMHGT(B,C,JJ)
52800 COMMON /Q/Q(1)
52900 BB=0
53000 IF(ABS(B).LT.80)GO TO 1
53100 C JUMP IF NOT MINI-BEAM
53200 BB=B-100.
53300 IF(B.LT.0)BB=B+100.
53400 B=BB
53500 1 BC=ABS(Q(JJ+7))
53600 IF(BC.GE.20.)GO TO 121
53700 IF(B.GE.0.AND.C.GE.0)RETURN
53800 C NEXT TO CHANGE HGT. OF BEAMS TOO HIGH OR TOO LOW.
53900 BC=-C
54000 IF(B.LT.C)BC=-B
54100 C -B IF C IS LOWEST
54200 122 IF(BB.NE.0)B=B+100.
54300 Q(JJ+4)=B+BC
54400 Q(JJ+5)=C+BC
54500 C BOTH SIDES ARE NOW SHIFTED
54600 RETURN
54700 121 IF(B.LE.14.AND.C.LE.14)RETURN
54800 C NOW AT LEAST ONE SIDE IS TOO HIGH
54900 BC=14-C
55000 IF(B.GT.C)BC=14-B
55100 GO TO 122
55200 END
55300
55400 SUBROUTINE CUES
55500 COMMON /PX/KPN(1)/XRN/RN(1)/PTR/KWDS(1)/RCLF/KK,CLEF,KW,ITEM
55600 1 /LLL/LLL /Q/Q(1)
55700
55800 DO 1 K=LLL,1,-1
55900 C BACK THROUGH ARRAY FROM LAST CUE FOUND.
56000 IF(CODEN(KPN,K,Q,J).NE.2)GO TO 1
56100 C NEXT FOUND A REST
56200 IF(Q(J).LT.8)GO TO 1
56300 C JUMP IF WDCNT IS TOO SMALL
56400 IF(Q(J+10).LT.100)GO TO 1
56500 C P10=100+STAFF NUM. OF CUE DATA. JUMP IF IMPROPER NUM.
56600 STF=Q(J+10)-100.
56700 POS=Q(J+3)
56800 C POSITION OF THIS REST
56900 PLEFT=0
57000 PRGHT=1000
57100 C POSITIONS FOR BARS TO LEFT AND RIGHT. NEXT FIND PROPER BARS.
57200
57300 DO 2 L=1,ITEM
57400 IF(CODEN(KWDS,L,RN,N).NE.4)GO TO 2
57500 C FIND A BAR AND ITS POS.
57600 X=RN(N+3)
57700 IF(X.GT.POS)GO TO 3
57800 C IS TO LEFT OR RIGHT OF REST?
57900 IF(X.GT.PLEFT)PLEFT=X
58000 GO TO 2
58100 3 IF(X.LT.PRGHT)PRGHT=X
58200 2 CONTINUE
58300 C NOW FOUND BARS ON EACH SIDE OF REST.
58400
58450 KLEF=0
58500 DO 4 L=1,ITEM
58600 C NOW FIND NOTES WITHIN PROPER BAR AND ON PROPER STAFF
58700 R=CODEN(KWDS,L,RN,N)
58800 IF(RN(N+2).NE.STF)GO TO 4
58900 RS=RN(N+3)
59000 C POS. OF ITEM.
59100 IF(RS.GT.PRGHT)GO TO 4
59200 IF(RS.LT.PLEFT)GO TO 4
59300 C NOW BETWEEN BARS.
59400 IF(R.GT.6)GO TO 4
59500 C USE NOTES,RESTS,CLEFS,SLURS,BEAMS
59600 IF(R.EQ.5) GO TO 44
59700 RNN=RN(N+4)
59800 IF(RNN.LT.100)RN(N+4)=RNN+100.
59900 C MAKE ALL NOTES INTO MINIS AND PUT ON STAFF 0
60000 44 RN(N+2)=0
60100 IF(R.NE.3)GO TO 55
60200 C IS IT A CODE 3? CHANGE NON-CLEFS TO CODE 33.
60300 IF(RN(N+5).LT.6)GO TO 66
60400 C JUMP FOR REAL CLEF
60500 RN(N+1)=33
60600 GO TO 55
60700 66 RN(N+4)=100
60800 C ALWAYS MINI-CLEF IN CUES.
60820 KLEF=N
60840 ITX=L
60900 55 IF(R.GT.2)GO TO 5
61000 JJ=N+11-R*2.0
61100 RN(JJ)=RN(JJ)/2.
61200 C JJ=9 OR 7. CUT RHYTH VALS OF CUES 1/2 - SO THEY WILL OCCUPY LESS SPACE.
61300 5 CALL QRN(N,KPN,L)
61400 C GO PUT IT INTO Q ARRAY
61500 4 CONTINUE
61600
61605 IF(KLEF.EQ.0)GO TO 6
61610 C NOW REPLACE ORIGINAL CLEF
61615 R=RN(KLEF+5)
61620 IF(RN(KLEF).LE.2.)R=0
61625 IF(R.EQ.CLEF)GO TO 6
61630 RN(KLEF+5)=CLEF
61635 C RN(KLEF)=5
61640 RN(KLEF+3)=PRGHT-1.
61645 CALL QRN(KLEF,KPN,ITX)
61700 CC Q(J+3)=POS+1
61800 C SHIFT THE WHOLE REST A BIT TO THE RIGHT.
61900 6 Q(J+10)=0
62000 Q(J+4)=5.
62100 C PUT IT ABOVE STAFF.
62200 Q(J+5)=-2
62300 C P5=-2=WHOLE REST
62400 Q(J+9)=0
62500 CC Q(J+8)=-1.
62600 Q(J+7)=-1.
62700 C NEG. RHYTHM MAKES REST IGNORED BY ALL JUSTIFYING ROUTINES.
62800 1 CONTINUE
62900 END